Widget System Risk Analysis Report

Example quantrr risk analysis of the “Widget Management System” (WMS).

library(quantrr)
library(readxl)
library(janitor)
library(validate)
library(dplyr)
library(formattable)
library(purrr)
library(ggplot2)
library(plotly)

# TODO: workaround for https://github.com/r-lib/lintr/issues/2790, update when
#   https://github.com/data-cleaning/validate/pull/197 is released (1.1.6+)
is.nzchar <- nzchar # nolint: object_name_linter.

# set the relative file path and name to import
report_file <- "data/widgetsys.xlsx"

Environment Statement

The Widget Management System (WMS) is over 30 years old and its architecture has not changed significantly since the original implementation. Over the years, the widget system has become an integral part of our services in managing widgets for our clients. In reviewing the system, three major risks were identified: First, the age of the technology prevents updating components of the system that no longer meet contemporary cybersecurity standards, which increases the likelihood of a breach. Second, the system is less reliable and experiences frequent outages, typically about 2 major outages per year, which results in lost revenue, contractual penalties, and overtime pay to recover from the incident. Third, limitations of the widget system have started to affect sales - we have recently lost a customer due to the functional obsolescence of the widget system, and expect to both lose more existing and prospective customers in the future due to increased competition in the widget management market.

Experts were asked to consider two risk treatment scenarios:

• None: The current system as it is today (baseline risk)
• Replace: Complete replacement of the WMS with a modern, customer-centric solution

Import

Import and validate data from Excel.

The data was collected from 3 Technology SMEs, 3 Business SMEs, and one SME with experience in both. Experts were calibrated, informed by historical and industry data, and only gave estimates for areas in which they were confident in answering.

risks <- read_xlsx(report_file, sheet = "Risks") |>
  clean_names()

validate_risks <- local({
  validate_rules <- validator(
    risk_char = is.character(risk),
    risk_not_na = !is.na(risk),
    risk_not_blank = is.nzchar(risk, keep_na = TRUE),
    desc_char = is.character(description),
    desc_not_na = !is.na(description),
    desc_not_blank = is.nzchar(risk, keep_na = TRUE)
  )
  confront(risks, validate_rules)
})

check_validation(validate_risks, sheet = "Risks")

treatments <- read_xlsx(report_file, sheet = "Treatments") |>
  clean_names()

validate_treatments <- local({
  validate_rules <- validator(
    treatment_char = is.character(treatment),
    treatment_not_na = !is.na(treatment),
    treatment_not_blank = is.nzchar(treatment, keep_na = TRUE),
    desc_char = is.character(description),
    desc_not_na = !is.na(description),
    desc_not_blank = is.nzchar(treatment, keep_na = TRUE)
  )
  confront(treatments, validate_rules)
})

check_validation(validate_treatments, sheet = "Treatments")

estimates <- read_xlsx(report_file, sheet = "Estimates") |>
  clean_names() |>
  rename(
    lambda = frequency_per_yer, p05 = low_5_percent, p95 = high_95_percent, p50 = most_likely
  )

validate_estimates <- local({
  validate_rules <- validator(
    risk_not_na = !is.na(risk),
    risk_match = risk %in% risks$risk,
    expert_char = is.character(expert),
    expert_not_na = !is.na(expert),
    expert_not_blank = is.nzchar(expert, keep_na = TRUE),
    lambda_num = is.numeric(lambda),
    lambda_pos = lambda > 0,
    p05_num = is.numeric(p05),
    p05_pos = p05 > 0,
    p95_num = is.numeric(p95),
    p95_pos = p95 > 0,
    p50_num = is.numeric(p50),
    p50_pos = p50 > 0
  )
  confront(estimates, validate_rules)
})

check_validation(validate_estimates, sheet = "Estimates")

Risks

Risk descriptions:

formattable(risks, align = "l")

risk	description
Cybersecurity Breach	Risk of a cybersecurity breach of the inventory system.
Technology Outage	Risk of an inventory system outage.
Loss of Customer	Risk of losing and existing customer or failure to acquire a new customer due to functional limitations of the inventory system.

Treatment descriptions:

formattable(treatments, align = "l")

treatment	description
None	Current system as it is today
Replace	Replace WMS with a modern solution

Forecast

Forecast risk using Monte Carlo simulation. The average events, losses, ‘typical’ losses (geometric mean), and percentage of years with no losses for each risk and treatment are summarized below:

consensus <- estimates |>
  group_by(treatment, risk) |>
  summarize(across(lambda:p50, ~ mean(.x, na.rm = TRUE)), .groups = "drop")

consensus_params <- consensus |>
  mutate(as_tibble(lnorm_param(.data$p05, .data$p95, .data$p50)))

forecast <- consensus_params |>
  select(c("risk", "lambda", "meanlog", "sdlog", "treatment")) |>
  pmap(calc_risk) |>
  list_rbind()

forecast |>
  group_by(treatment, risk) |>
  mutate(no_losses = events == 0) |>
  summarize(
    avg_events = mean(events), avg_losses = mean(losses), typ_losses = gmean(losses),
    no_losses = mean(no_losses), .groups = "drop"
  ) |>
  mutate(
    across(avg_losses:typ_losses, ~ currency(.x, digits = 0L)),
    no_losses = percent(no_losses)
  ) |>
  formattable(align = "l")

treatment	risk	avg_events	avg_losses	typ_losses	no_losses
None	Cybersecurity Breach	0.25426	$9,384,651	$355,544	77.55%
None	Loss of Customer	2.00286	$10,252,514	$4,297,963	13.54%
None	Technology Outage	1.98792	$96,379	$35,155	13.67%
Replace	Cybersecurity Breach	0.10164	$3,745,624	$307,230	90.34%
Replace	Loss of Customer	0.23780	$1,144,349	$1,576,494	78.88%
Replace	Technology Outage	1.12432	$42,337	$19,139	32.73%

Losses

Baseline losses (with no risk treatment) by risk separately and in aggregate:

forecast |>
  filter(tolower(treatment) == "none") |>
  # remove zero losses to plot using log10 scale
  filter(losses > 0) |>
  ggplot(aes(losses)) +
  facet_grid(vars(risk)) +
  geom_histogram(color = "black", fill = "white", bins = 100) +
  scale_x_log10(labels = scales::label_currency(scale_cut = scales::cut_short_scale())) +
  labs(x = NULL, y = NULL, title = "Losses by Risk") +
  theme_minimal()

forecast |>
  filter(tolower(treatment) == "none") |>
  filter(losses > 0) |>
  ggplot(aes(losses, fill = risk)) +
  geom_histogram(bins = 100) +
  scale_x_log10(labels = scales::label_currency(scale_cut = scales::cut_short_scale())) +
  labs(x = NULL, y = NULL, fill = "Risk", title = "Total Losses") +
  scale_fill_viridis_d() +
  theme_minimal()

Loss Exceedance Curves

Plot loss exceedance curves for all risks and combined risk, with risk treatments.

By Risk

Plot loss exceedance curves for each risk:

risk_le <- forecast |>
  group_by(risk, treatment) |>
  mutate(probability = 1 - percent_rank(losses)) |>
  filter(losses > 0) |>
  ungroup() |>
  mutate(losses = currency(losses, digits = 0), probability = percent(probability)) |>
  ggplot(aes(losses, probability, color = treatment)) +
  facet_grid(vars(risk)) +
  geom_line() +
  scale_y_continuous(labels = scales::label_percent(), limits = c(0, 1)) +
  scale_x_log10(labels = scales::label_currency(scale_cut = scales::cut_short_scale())) +
  labs(x = NULL, y = NULL, color = "Treatment", title = "Loss Exceedance by Risk") +
  scale_color_viridis_d() +
  theme_minimal()

risk_le

Interactive plot:

ggplotly(risk_le + guides(color = "none"))